home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / jx4nt123.zip / JAX4TH.I < prev    next >
Text File  |  1994-09-05  |  12KB  |  441 lines
  1. ; jax4th.inc ... 32-bit ANS Forth for Windows NT
  2. ; copyright (c) 1993, 1994 by jack j. woehr
  3. ; p.o. box 51, golden, co 80402-0051
  4. ; jax@well.sf.ca.us | JAX on GEnie | 72203.1320@compuserve.com
  5. ; sysop, rcfb (303) 278-0364
  6.  
  7.     COMMENT    !
  8. This program is free software; you can redistribute it and/or modify
  9. it under the terms of the GNU General Public License as published by
  10. the Free Software Foundation; either version 2 of the License, or
  11. (at your option) any later version.
  12.  
  13. This program is distributed in the hope that it will be useful,
  14. but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. GNU General Public License for more details. (doc\license.txt)
  17.  
  18. You should have received a copy of the GNU General Public License
  19. along with this program; if not, write to the Free Software
  20. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  21. !
  22.  
  23. ;-----------------------;
  24. ; Register equates    ;
  25. ;-----------------------;
  26.  
  27. ip    textequ    <esi>    ; Forth instruction pointer
  28. dsp    textequ    <esp>    ; Forth data stack pointer
  29. rp    textequ    <ebp>    ; Forth return stack pointer
  30. wp    textequ    <eax>    ; Indirect-threading word pointer
  31. cp    textequ    <edi>    ; Pointer to user dictionary
  32. dp    textequ    <ebx>    ; Pointer to data space
  33.  
  34. ;---------------;
  35. ; Constants    ;
  36. ;---------------;
  37.  
  38. ; Scaling
  39. tchar    equ    2    ; Unicode characters    
  40. cell    equ    4    ; 32-bit Forth, byte-addressing processor
  41.  
  42. ; Boolean
  43. TRUE    equ    0FFFFFFFFH
  44. FALSE    equ    0
  45.  
  46. ; Chars
  47. UniNotAChar    equ    0FFFFH    ; illegal Unicode char
  48. cRet        equ    000DH    ; carriage return
  49. lFeed        equ    000AH    ; line feed
  50.  
  51. ;---------------;
  52. ; Bit Masks    ;
  53. ;---------------;
  54.  
  55. immedMask    equ    8000H        ; in name count word, marks word as immediate
  56. allNameMasks    equ    immedMask    ; all non-count bits used in name count word
  57. userdictbit    equ    31
  58. userdictmask    equ    80000000H
  59.  
  60. ;-----------------------;
  61. ; System factors    ;
  62. ;-----------------------;
  63.  
  64. dStackSize    equ    4000H        ; half for data stack
  65. rStackSize    equ    4000H        ; half for return
  66. stackstackSize    equ    dStackSize + rStackSize    ; complete stack allocation, as requested in linker statement in makefile
  67. defDataSize    equ    10000H        ; default data space size
  68. defDictSize    equ    10000H         ; default user dictionary size
  69. tibsize        equ    256        ; terminal input buffer size
  70. searchOrderSize    equ    8        ; max wordlists in search order
  71. blockSize    equ    1024        ; number of chars in a BLOCK
  72. rlbuffsize    equ    tibsize        ; maximum chars for READ-LINE is same as TIB for now
  73.  
  74. ;---------------;
  75. ; Error Returns    ;
  76. ;---------------;
  77.  
  78. userErr        equ    2000000H    ; No Windows API error code has bit 29 set ( 0x20000000)
  79.  
  80. ;---------------;
  81. ; Macros    ;
  82. ;---------------;
  83.  
  84. ;--( System Macros )
  85.  
  86. ; Embed a string as Unicode
  87. unicode    macro    aString
  88.     irpc    x,<aString>
  89.     db    '&x',0            ;; assemble as little-endian double-byte char
  90.     endm
  91. endm
  92.  
  93. ;--( Code Macros )
  94.  
  95. ; Store to a Forth VARIABLE offset from assembly
  96. store    macro    dataOffset,source
  97.     mov    DWORD PTR [dp+dataOffset],source
  98. endm
  99.  
  100. ; Fetch From a Forth VARIABLE offset from assembly
  101. fetch    macro    dest,dataOffset
  102.     mov    dest,DWORD PTR [dp+dataOffset]
  103. endm
  104.  
  105. ;--( Dictionary Macros )
  106.  
  107. ; Assign offsets in data space for Forth variables.
  108. varptr    =    0            ; an allocation pointer
  109. avar    macro    varName            
  110. varName =    varptr
  111. varptr    = varptr+cell
  112. endm
  113.  
  114. ; Assembly-time allocation of data space by cells
  115. allotCells    macro    aName,numCells
  116. aName    =    varptr
  117. varptr    =    varptr + (numCells*cell)
  118. endm
  119.  
  120. ; Back-links at head of various wordlists, single-threaded
  121. flinkptr    =    0            ; FORTH-WORDLIST        Standard words
  122. zlinkptr    =    0            ; INTERNALS-WORDLIST        Internals
  123. nlinkptr    =    0            ; NONSTANDARD-WORDLIST        Non-standard Forth words
  124. slinkptr    =    0            ; SYSTEM-WORDLIST        System calls, etc.
  125.  
  126. linkme    macro    linkpointer
  127.     align    cell
  128.     dd    linkpointer            ;; embedded back-link
  129. linkpointer    =    $-cell            ;; point to address at which link pointer was compiled
  130. endm
  131.  
  132. ; Create a count DWORD consisting of 0xFFFF followed by the character count so that an unambguous marker may be
  133. ; found when searching back from the CFA.
  134.  
  135. countcell    macro    aCount
  136.     align    cell
  137.     dw    0FFFFH
  138.     dw    aCount
  139. endm
  140.  
  141. ; Create a non-IMMEDIATE name header consisting of count char and name chars.
  142. ; Mostly called by macro NAME, but this factoring is necessary because of chars like * / # in Forth names.
  143. namemanque    macro    aName,linkpointer
  144.     linkme    linkpointer
  145. namecntr    =    0
  146.     irpc    x,aName
  147.     namecntr    =    namecntr+1
  148.     endm
  149.     countcell    namecntr
  150.     unicode    aName
  151.     align    cell
  152. endm
  153.  
  154. ; Create a non-IMMEDIATE name header consisting of count char and name chars as above,
  155. ; but also define a token label for it. This is the normal call. NAYME is spelled funny because NAME is MASM keyword.
  156. nayme    macro    aName,linkpointer
  157.     namemanque    aName,linkpointer
  158. fw_&aName:
  159. endm
  160.  
  161. ; Create an IMMEDIATE name header consisting of count char and name chars.
  162. ; Mostly called by macro INAME, but this factoring is necessary because of chars like * / # in Forth names.
  163. inamemanque    macro    aName,linkpointer
  164.     linkme    linkpointer
  165. namecntr    =    0
  166.     irpc    x,aName
  167.     namecntr    =    namecntr+1
  168.     endm
  169.     countcell    <namecntr or immedMask>
  170.     unicode    aName
  171.     align    cell
  172. endm
  173.  
  174. ; Create an IMMEDIATE name header consisting of count char and name chars as above,
  175. ; but also define a token label for it. This is the normal call.
  176. iname    macro    aName,linkpointer
  177.     inamemanque    aName,linkpointer
  178. fw_&aName:
  179. endm
  180.  
  181. ; Create non-IMMEDIATE header for FORTH-WORDLIST
  182. fname    macro    aName
  183.     nayme    aName,flinkptr
  184. endm
  185.  
  186. ; Create an IMMEDIATE header for FORTH-WORDLIST
  187. finame    macro    aName
  188.     iname    aName,flinkptr
  189. endm
  190.  
  191. ; Create non-IMMEDATE header without label for FORTH-WORDLIST
  192. fnamemanque    macro    aName
  193.     namemanque    aName,flinkptr
  194. endm
  195.  
  196. ; Create IMMEDIATE header without label for FORTH-WORDLIST
  197. finamemanque    macro    aName
  198.     inamemanque    aName,flinkptr
  199. endm
  200.  
  201. ; Create non-IMMEDIATE header for INTERNALS-WORDLIST
  202. zname    macro    aName
  203.     nayme    aName,zlinkptr
  204. endm
  205.  
  206. ; Create an IMMEDIATE header for INTERNALS-WORDLIST
  207. ziname    macro    aName
  208.     iname    aName,zlinkptr
  209. endm
  210.  
  211. ; Create non-IMMEDATE header without label for INTERNALS-WORDLIST
  212. znamemanque    macro    aName
  213.     namemanque    aName,zlinkptr
  214. endm
  215.  
  216. ; Create IMMEDIATE header without label for INTERNALS-WORDLIST
  217. zinamemanque    macro    aName
  218.     inamemanque    aName,zlinkptr
  219. endm
  220.  
  221. ; Create non-IMMEDIATE header for NONSTANDARD-WORDLIST
  222. nname    macro    aName
  223.     nayme    aName,nlinkptr
  224. endm
  225.  
  226. ; Create an IMMEDIATE header for NONSTANDARD-WORDLIST
  227. niname    macro    aName
  228.     iname    aName,nlinkptr
  229. endm
  230.  
  231. ; Create non-IMMEDATE header without label for NONSTANDARD-WORDLIST
  232. nnamemanque    macro    aName
  233.     namemanque    aName,nlinkptr
  234. endm
  235.  
  236. ; Create IMMEDIATE header without label for NONSTANDARD-WORDLIST
  237. ninamemanque    macro    aName
  238.     inamemanque    aName,nlinkptr
  239. endm
  240.  
  241. ; Create non-IMMEDIATE header for SYSTEM-WORDLIST
  242. sname    macro    aName
  243.     nayme    aName,slinkptr
  244. endm
  245.  
  246. ; Create an IMMEDIATE header for SYSTEM-WORDLIST
  247. siname    macro    aName
  248.     iname    aName,slinkptr
  249. endm
  250.  
  251. ; Create non-IMMEDATE header without label for SYSTEM-WORDLIST
  252. snamemanque    macro    aName
  253.     namemanque    aName,slinkptr
  254. endm
  255.  
  256. ; Create IMMEDIATE header without label for SYSTEM-WORDLIST
  257. sinamemanque    macro    aName
  258.     inamemanque    aName,slinkptr
  259. endm
  260.  
  261. ; Assemble execution token into a Forth definition
  262. ; Kernel tokens are flat addresses
  263. ctok    macro    aName
  264.     dd    fw_&aName    ;; for kernel tokens
  265. endm
  266.  
  267. ;--( Execution Macros )
  268.  
  269. ; Push an item on the return stack
  270. pushrp    macro    source
  271.     sub    rp,cell
  272.     mov    [rp],source
  273. endm
  274.  
  275. ; Pop an item from the return stack and discard
  276. poprp    macro
  277.     add    rp,cell
  278. endm
  279.  
  280. ; Pop an item for the return stack to a destination
  281. poprpto    macro    dest
  282.     mov    dest,[rp]
  283.     poprp
  284. endm
  285.  
  286. ; The Forth NEXT routine
  287. ; User dict tokens are distinguised from kernel tokens by their "odd"-ness.
  288. ; Here is the inner next routine once WP is loaded with a token:
  289. innext    macro            ;; on entry, WP already contains token found by instruction pointer
  290.     local    kerntok,kernex
  291.     btr    wp,userdictbit    ;; user dict tokens are (addr|userdictbit)-cp
  292.     jnc    SHORT    kerntok
  293.     add    wp,cp        ;; add base
  294. kerntok:    
  295.     mov    edx,[wp]    ;; deference indirect pointer to execution engine
  296.     btr    edx,userdictbit    ;; user pointers to kern exe engines are (addr|userdictbit) - cp
  297.     jnc    SHORT    kernex
  298.     add    edx,cp        ;; add base
  299. kernex:
  300.     jmp    edx
  301. endm
  302.  
  303. ; Here is the entire next routine:
  304. next    macro
  305.     lodsd            ;; WP (EAX) := @IP++
  306.     innext            ;; execute the token in WP
  307. endm
  308.  
  309. ; Used by conditionals compiled in user dictionary .. token is in WP
  310. dereftok    macro
  311.     local    kerntok
  312.     btr    wp,userdictbit        ;; user dict tokens are (addr|userdictbit)-cp
  313.     jnc    SHORT    kerntok
  314.     add    wp,cp        ;; add base
  315. kerntok:    
  316. endm
  317.  
  318. ;--( Compilation Macros )
  319.  
  320. docode    macro
  321.     dd    $+cell
  322. endm
  323.  
  324. defers    macro            ;; value must be init'ed at boot time
  325.     ctok    DODEFER
  326.     dd    varptr
  327. varptr    =    varptr + cell
  328. endm
  329.  
  330. literal    macro    aLit
  331.     ctok    DOLIT
  332.     dd    aLit
  333. endm
  334.  
  335. charlit    macro    aChar        ;; accepts ASCII only
  336.     ctok    DOLIT
  337.     db    aChar,0,0,0
  338. endm
  339.  
  340. compif    macro    aLabel        ;; also WHILE
  341.     ctok    DOIF
  342.     dd    aLabel
  343. endm
  344.  
  345. compelse    macro    aLabel    ;; also REPEAT AGAIN
  346.     ctok    DOELSE
  347.     dd    aLabel
  348. endm
  349.  
  350. compuntil    macro    aLabel
  351.     ctok    DOUNTIL
  352.     dd    aLabel
  353. endm
  354.  
  355. compdo    macro    aLabel
  356.     ctok    DODO
  357.     dd    aLabel
  358. endm
  359.  
  360. comploop    macro    aLabel
  361.     ctok    DOLOOP
  362.     dd    aLabel
  363. endm
  364.  
  365. compqdo    macro    aLabel
  366.     ctok    DOQDO
  367.     dd    aLabel
  368. endm
  369.  
  370. compplloop    macro    aLabel
  371.     ctok    DOPLUSLOOP
  372.     dd    aLabel
  373. endm
  374.  
  375. ;-----------------------;
  376. ; Forth Data Space    ;
  377. ;-----------------------;
  378.  
  379. ;--( Variables )
  380.  
  381.     avar    lastCatch        ; holds catch frame pointer
  382.     avar    lastCaught        ; holds IP pointing to cell following THROW
  383.     avar    conMode            ; Holds Console Mode
  384.     avar    lastError        ; TRUE for no error or an error code after funcalls
  385.     avar    outChar            ; hold one char for output
  386.     avar    ntConEBP        ; holds value of EBP from startup
  387.     avar    ntConESP        ; holds value of ESP from startup
  388.     avar    rpzero            ; holds Forth's initial setting of RP
  389.     avar    memHandle        ; pointer to allocated memory block
  390.     avar    stdIn            ; Console handle
  391.     avar    stdOut            ; Console handle
  392.     avar    stdErr            ; Console handle
  393.     avar    datap            ; Returned by HERE
  394.     avar    dictp            ; Dictionary space pointer
  395.     avar    flinkp            ; Last FORTH-WORDLIST link
  396.     avar    zlinkp            ; Last INTERNALS-WORDLIST link
  397.     avar    nlinkp            ; Last NONSTANDARD-WORDLIST link
  398.     avar    slinkp            ; Last SYSTEM-WORDLIST link
  399.     avar    wllink            ; points to last wordlist in chain
  400.     avar    endq            ; TRUE when input stream found to be at end in FIND
  401.     avar    nonaming        ; TRUE if the current definition was initiated by :NONAME
  402.     avar    var_hld            ; used by <# # #S HOLD #>
  403.     avar    var_state        ; STATE variable
  404.     avar    var_blk            ; BLK variable
  405.     avar    var_scr            ; SCR variable
  406.     avar    var_srcid        ; SOURCE-ID variable
  407.     avar    var_numtib        ; #TIB variable
  408.     avar    var_tib            ; 'TIB variable
  409.     avar    var_to_in        ; >IN variable
  410.     avar    var_base        ; BASE variable
  411.     avar    var_dpl            ; DPL variable, holds position of "dot" (.) in number input
  412.     avar    last            ; holds link token of last entry added to dictionary
  413.     avar    cstack            ; saved stack pointer during compilation
  414.     avar    current            ; current compilation wordlist
  415.     avar    blockFile        ; holds handle for active BLOCK file
  416.     avar    blockNum        ; holds number of block in buffer
  417.     avar    updated            ; TRUE if block has been updated
  418.     avar    inDefinition        ; TRUE if compiling a : (colon) or :NONAME definition
  419.     avar    var_ferror        ; holds error from last bum file operation    
  420.  
  421. ;--( Larger Items )
  422.  
  423.     allotCells    searchOrder,searchOrderSize    ; search order array
  424.  
  425. ;--( Buffers )
  426.     allotCells    wordBuffer,(256*tchar)/cell    ; holds result of WORD
  427.     allotCells    stringBuffer,(256*tchar)/cell    ; holds result of interpretive S"
  428.     allotCells    asciizBuffer,256/cell        ; holds converted asciiz strings for syscalls
  429.     allotCells    blockBuffer,(blockSize*tchar)/cell    ; our single block buffer
  430.     allotCells    ticktib,(tibsize*tchar)/cell    ; input buffer
  431.     allotCells    tickpad,(128*tchar)/cell    ; pad buffer
  432.     allotCells    tickftib,(tibsize*tchar)/cell    ; file input buffer
  433.     allotCells    ticknum,(128*tchar)/cell    ; numeric output conversion buffer
  434. ticknumend    equ    varptr                ; end of numeric conversion buffer
  435.     allotCells    rlBuffer,((rlbuffsize+2)*tchar)/cell
  436.                             ; READ-LINE buffer, 256 + 2 for EOL chars
  437.     allotCells    zeroBuffer,(tibsize*tchar)/cell    ; CREATE-FILE needs a zero-pad buffer
  438.                             ; Can't expect the user to do it.
  439. ; END of jax4th.i
  440.  
  441.